home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
akcl
/
kcl.lha
/
lsp
/
describe.lsp
< prev
next >
Wrap
Lisp/Scheme
|
1987-06-04
|
16KB
|
425 lines
;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
;; Copying of this file is authorized to users who have executed the true and
;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
;;;; describe.lsp
;;;;
;;;; DESCRIBE and INSPECT
(in-package 'lisp)
(export '(describe inspect))
(in-package 'system)
(proclaim '(optimize (safety 2) (space 3)))
(defvar *inspect-level* 0)
(defvar *inspect-history* nil)
(defvar *inspect-mode* nil)
(defvar *old-print-level* nil)
(defvar *old-print-length* nil)
(defun inspect-read-line ()
(do ((char (read-char *query-io*) (read-char *query-io*)))
((or (char= char #\Newline) (char= char #\Return)))))
(defun read-inspect-command (label object allow-recursive)
(unless *inspect-mode*
(inspect-indent-1)
(if allow-recursive
(progn (princ label) (inspect-object object))
(format t label object))
(return-from read-inspect-command nil))
(loop
(inspect-indent-1)
(if allow-recursive
(progn (princ label)
(inspect-indent)
(prin1 object))
(format t label object))
(write-char #\Space)
(force-output)
(case (do ((char (read-char *query-io*) (read-char *query-io*)))
((and (char/= char #\Space) (char/= #\Tab)) char))
((#\Newline #\Return)
(when allow-recursive (inspect-object object))
(return nil))
((#\n #\N)
(inspect-read-line)
(when allow-recursive (inspect-object object))
(return nil))
((#\s #\S) (inspect-read-line) (return nil))
((#\p #\P)
(inspect-read-line)
(let ((*print-pretty* t) (*print-level* nil) (*print-length* nil))
(prin1 object)
(terpri)))
((#\a #\A) (inspect-read-line) (throw 'abort-inspect nil))
((#\u #\U)
(return (values t (prog1
(eval (read-preserving-whitespace *query-io*))
(inspect-read-line)))))
((#\e #\E)
(dolist (x (multiple-value-list
(multiple-value-prog1
(eval (read-preserving-whitespace *query-io*))
(inspect-read-line))))
(write x
:level *old-print-level*
:length *old-print-length*)
(terpri)))
((#\q #\Q) (inspect-read-line) (throw 'quit-inspect nil))
(t (inspect-read-line)
(terpri)
(format t
"Inspect commands:~%~
n (or N or Newline): inspects the field (recursively).~%~
s (or S): skips the field.~%~
p (or P): pretty-prints the field.~%~
a (or A): aborts the inspection ~
of the rest of the fields.~%~
u (or U) form: updates the field ~
with the value of the form.~%~
e (or E) form: evaluates and prints the form.~%~
q (or Q): quits the inspection.~%~
?: prints this.~%~%")))))
(defmacro inspect-recursively (label object &optional place)
(if place
`(multiple-value-bind (update-flag new-value)
(read-inspect-command ,label ,object t)
(when update-flag (setf ,place new-value)))
`(when (read-inspect-command ,label ,object t)
(princ "Not updated.")
(terpri))))
(defmacro inspect-print (label object &optional place)
(if place
`(multiple-value-bind (update-flag new-value)
(read-inspect-command ,label ,object nil)
(when update-flag (setf ,place new-value)))
`(when (read-inspect-command ,label ,object nil)
(princ "Not updated.")
(terpri))))
(defun inspect-indent ()
(fresh-line)
(format t "~V@T"
(* 4 (if (< *inspect-level* 8) *inspect-level* 8))))
(defun inspect-indent-1 ()
(fresh-line)
(format t "~V@T"
(- (* 4 (if (< *inspect-level* 8) *inspect-level* 8)) 3)))
(defun inspect-symbol (symbol)
(let ((p (symbol-package symbol)))
(cond ((null p)
(format t "~:@(~S~) - uninterned symbol" symbol))
((eq p (find-package "KEYWORD"))
(format t "~:@(~S~) - keyword" symbol))
(t
(format t "~:@(~S~) - ~:[internal~;external~] symbol in ~A package"
symbol
(multiple-value-bind (b f)
(find-symbol (symbol-name symbol) p)
(declare (ignore b))
(eq f :external))
(package-name p)))))
(when (boundp symbol)
(if *inspect-mode*
(inspect-recursively "value:"
(symbol-value symbol)
(symbol-value symbol))
(inspect-print "value:~% ~S"
(symbol-value symbol)
(symbol-value symbol))))
(do ((pl (symbol-plist symbol) (cddr pl)))
((endp pl))
(unless (and (symbolp (car pl))
(or (eq (symbol-package (car pl)) (find-package 'system))
(eq (symbol-package (car pl)) (find-package 'compiler))))
(if *inspect-mode*
(inspect-recursively (format nil "property ~S:" (car pl))
(cadr pl)
(get symbol (car pl)))
(inspect-print (format nil "property ~:@(~S~):~% ~~S" (car pl))
(cadr pl)
(get symbol (car pl))))))
(when (print-doc symbol t)
(format t "~&-----------------------------------------------------------------------------~%"))
)
(defun inspect-package (package)
(format t "~S - package" package)
(when (package-nicknames package)
(inspect-print "nicknames: ~S" (package-nicknames package)))
(when (package-use-list package)
(inspect-print "use list: ~S" (package-use-list package)))
(when (package-used-by-list package)
(inspect-print "used-by list: ~S" (package-used-by-list package)))
(when (package-shadowing-symbols package)
(inspect-print "shadowing symbols: ~S"
(package-shadowing-symbols package))))
(defun inspect-character (character)
(format t
(cond ((standard-char-p character) "~S - standard character")
((string-char-p character) "~S - string character")
(t "~S - character"))
character)
(inspect-print "code: #x~X" (char-code character))
(inspect-print "bits: ~D" (char-bits character))
(inspect-print "font: ~D" (char-font character)))
(defun inspect-number (number)
(case (type-of number)
(fixnum (format t "~S - fixnum (32 bits)" number))
(bignum (format t "~S - bignum" number))
(ratio
(format t "~S - ratio" number)
(inspect-recursively "numerator:" (numerator number))
(inspect-recursively "denominator:" (denominator number)))
(complex
(format t "~S - complex" number)
(inspect-recursively "real part:" (realpart number))
(inspect-recursively "imaginary part:" (imagpart number)))
((short-float single-float)
(format t "~S - short-float" number)
(multiple-value-bind (signif expon sign)
(integer-decode-float number)
(declare (ignore sign))
(inspect-print "exponent: ~D" expon)
(inspect-print "mantissa: ~D" signif)))
((long-float double-float)
(format t "~S - long-float" number)
(multiple-value-bind (signif expon sign)
(integer-decode-float number)
(declare (ignore sign))
(inspect-print "exponent: ~D" expon)
(inspect-print "mantissa: ~D" signif)))))
(defun inspect-cons (cons)
(format t
(case (car cons)
((lambda lambda-block lambda-closure lambda-block-closure)
"~S - function")
(quote "~S - constant")
(t "~S - cons"))
cons)
(when *inspect-mode*
(do ((i 0 (1+ i))
(l cons (cdr l)))
((atom l)
(inspect-recursively (format nil "nthcdr ~D:" i)
l (cdr (nthcdr (1- i) cons))))
(inspect-recursively (format nil "nth ~D:" i)
(car l) (nth i cons)))))
(defun inspect-string (string)
(format t (if (simple-string-p string) "~S - simple string" "~S - string")
string)
(inspect-print "dimension: ~D"(array-dimension string 0))
(when (array-has-fill-pointer-p string)
(inspect-print "fill pointer: ~D"
(fill-pointer string)
(fill-pointer string)))
(when *inspect-mode*
(dotimes (i (array-dimension string 0))
(inspect-recursively (format nil "aref ~D:" i)
(char string i)
(char string i)))))
(defun inspect-vector (vector)
(format t (if (simple-vector-p vector) "~S - simple vector" "~S - vector")
vector)
(inspect-print "dimension: ~D" (array-dimension vector 0))
(when (array-has-fill-pointer-p vector)
(inspect-print "fill pointer: ~D"
(fill-pointer vector)
(fill-pointer vector)))
(when *inspect-mode*
(dotimes (i (array-dimension vector 0))
(inspect-recursively (format nil "aref ~D:" i)
(aref vector i)
(aref vector i)))))
(defun inspect-array (array)
(format t (if (adjustable-array-p array)
"~S - adjustable aray"
"~S - array")
array)
(inspect-print "rank: ~D" (array-rank array))
(inspect-print "dimensions: ~D" (array-dimensions array))
(inspect-print "total size: ~D" (array-total-size array)))
(defun inspect-object (object &aux (*inspect-level* *inspect-level*))
(inspect-indent)
(when (and (not *inspect-mode*)
(or (> *inspect-level* 5)
(member object *inspect-history*)))
(prin1 object)
(return-from inspect-object))
(incf *inspect-level*)
(push object *inspect-history*)
(catch 'abort-inspect
(cond ((symbolp object) (inspect-symbol object))
((packagep object) (inspect-package object))
((characterp object) (inspect-character object))
((numberp object) (inspect-number object))
((consp object) (inspect-cons object))
((stringp object) (inspect-string object))
((vectorp object) (inspect-vector object))
((arrayp object) (inspect-array object))
(t (format t "~S - ~S" object (type-of object))))))
(defun describe (object &aux (*inspect-mode* nil)
(*inspect-level* 0)
(*inspect-history* nil)
(*print-level* nil)
(*print-length* nil))
"The lisp function DESCRIBE."
(terpri)
(catch 'quit-inspect (inspect-object object))
(terpri)
(values))
(defun inspect (object &aux (*inspect-mode* t)
(*inspect-level* 0)
(*inspect-history* nil)
(*old-print-level* *print-level*)
(*old-print-length* *print-length*)
(*print-level* 3)
(*print-length* 3))
"The lisp function INSPECT."
(read-line)
(princ "Type ? and a newline for help.")
(terpri)
(catch 'quit-inspect (inspect-object object))
(terpri)
(values))
(defun print-doc (symbol &optional (called-from-apropos-doc-p nil)
&aux (f nil) x)
(flet ((doc1 (doc ind)
(setq f t)
(format t
"~&-----------------------------------------------------------------------------~%~53S~24@A~%~A"
symbol ind doc))
(good-package ()
(if (eq (symbol-package symbol) (find-package "LISP"))
(find-package "SYSTEM")
*package*)))
(cond ((special-form-p symbol)
(doc1 (or (documentation symbol 'function) "")
(if (macro-function symbol)
"[Special form and Macro]"
"[Special form]")))
((macro-function symbol)
(doc1 (or (documentation symbol 'function) "") "[Macro]"))
((fboundp symbol)
(doc1
(or (documentation symbol 'function)
(if (consp (setq x (symbol-function symbol)))
(case (car x)
(lambda (format nil "~%Args: ~S" (cadr x)))
(lambda-block (format nil "~%Args: ~S" (caddr x)))
(lambda-closure
(format nil "~%Args: ~S" (car (cddddr x))))
(lambda-block-closure
(format nil "~%Args: ~S" (cadr (cddddr x))))
(t ""))
""))
"[Function]"))
((setq x (documentation symbol 'function))
(doc1 x "[Macro or Function]")))
(cond ((constantp symbol)
(unless (and (eq (symbol-package symbol) (find-package "KEYWORD"))
(null (documentation symbol 'variable)))
(doc1 (or (documentation symbol 'variable) "") "[Constant]")))
((si:specialp symbol)
(doc1 (or (documentation symbol 'variable) "")
"[Special variable]"))
((or (setq x (documentation symbol 'variable)) (boundp symbol))
(doc1 (or x "") "[Variable]")))
(cond ((setq x (documentation symbol 'type))
(doc1 x "[Type]"))
((setq x (get symbol 'deftype-form))
(let ((*package* (good-package)))
(doc1 (format nil "~%Defined as: ~S~%See the doc of DEFTYPE." x)
"[Type]"))))
(cond ((setq x (documentation symbol 'structure))
(doc1 x "[Structure]"))
((setq x (get symbol 'defstruct-form))
(doc1 (format nil "~%Defined as: ~S~%See the doc of DEFSTRUCT." x)
"[Structure]")))
(cond ((setq x (documentation symbol 'setf))
(doc1 x "[Setf]"))
((setq x (get symbol 'setf-update-fn))
(let ((*package* (good-package)))
(doc1 (format nil "~%Defined as: ~S~%See the doc of DEFSETF."
`(defsetf ,symbol ,(get symbol 'setf-update-fn)))
"[Setf]")))
((setq x (get symbol 'setf-lambda))
(let ((*package* (good-package)))
(doc1 (format nil "~%Defined as: ~S~%See the doc of DEFSETF."
`(defsetf ,symbol ,@(get symbol 'setf-lambda)))
"[Setf]")))
((setq x (get symbol 'setf-method))
(let ((*package* (good-package)))
(doc1
(format nil
"~@[~%Defined as: ~S~%See the doc of DEFINE-SETF-METHOD.~]"
(if (consp x)
(case (car x)
(lambda `(define-setf-method ,@(cdr x)))
(lambda-block `(define-setf-method ,@(cddr x)))
(lambda-closure `(define-setf-method ,@(cddddr x)))
(lambda-block-closure
`(define-setf-method ,@(cdr (cddddr x))))
(t nil))
nil))
"[Setf]"))))
)
(if called-from-apropos-doc-p
f
(progn (if f
(format t "~&-----------------------------------------------------------------------------")
(format t "~&No documentation for ~:@(~S~)." symbol))
(values))))
(defun apropos-doc (string &optional (package 'lisp) &aux (f nil))
(setq string (string string))
(if package
(do-symbols (symbol package)
(when (substringp string (string symbol))
(setq f (or (print-doc symbol t) f))))
(do-all-symbols (symbol)
(when (substringp string (string symbol))
(setq f (or (print-doc symbol t) f)))))
(if f
(format t "~&-----------------------------------------------------------------------------")
(format t "~&No documentation for ~S in ~:[any~;~A~] package."
string package
(and package (package-name (coerce-to-package package)))))
(values))